home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / record < prev    next >
Text File  |  1993-09-08  |  8KB  |  223 lines
  1. ; Record.scm.  This more or less implements the records that are
  2. ; proposed for R5RS - unfortunately, all records created in this
  3. ; manner look like vectors.  I believe the original record proposal
  4. ; was made by Jonathan Rees.  This implementation defines some symbols
  5. ; other than those that are part of the record proposal - this
  6. ; wouldn't be a problem if Scheme had a module system, but it doesn't.
  7.  
  8. ; Written by David Carlton, carlton@husc.harvard.edu.  This code is in
  9. ; the public domain.
  10. ; Extensively Modified for SLIB by Aubrey Jaffer, jaffer@ai.mit.edu.
  11. ; May 17 1992, MAKE-RECORD-SUB-TYPE added by jaffer.
  12.  
  13. (require 'common-list-functions)
  14.  
  15. ; Tags to help identify rtd's.  (A record is identified by the rtd
  16. ; that begins it.)
  17. (define record:*rtd-tag* (cons 'rtd '()))
  18.  
  19. ; Checks to see if a list has any duplicates.  Also checks to see if
  20. ; it a list, for that matter.
  21. (define (record:has-duplicates? lst)
  22.   (cond
  23.    ((null? lst) #f)
  24.    ((not (pair? lst)) #t)
  25.    ((memq (car lst) (cdr lst)) #t)
  26.    (else (record:has-duplicates? (cdr lst)))))
  27.  
  28. ; Various accessor functions.  No error checking; if you call these,
  29. ; you should know that they will work.
  30. (define (record:rtd-tag x) (vector-ref x 0))
  31. (define (record:rtd-name rtd) (vector-ref rtd 1))
  32. (define (record:rtd-supers rtd) (vector-ref rtd 2))
  33. (define (record:rtd-fields rtd) (vector-ref rtd 3))
  34. ;; rtd-vfields is padded out to the length of the vector, which is 1
  35. ;; more than the number of fields
  36. (define (record:rtd-vfields rtd) (cons #f (record:rtd-fields rtd)))
  37. ;; rtd-length is the length of the vector.
  38. (define (record:rtd-length rtd) (vector-ref rtd 4))
  39.  
  40. (define (record:record-rtd x) (vector-ref x 0))
  41. (define (record:record-supers x) (vector-ref (vector-ref x 0) 2))
  42.  
  43. (define (record-predicate rtd)
  44.   (if (not (record:rtd? rtd))
  45.       (slib:error "record-predicate: invalid argument." rtd))
  46.   (vector-ref rtd 5))
  47.  
  48. (define (record-sub-predicate rtd)
  49.   (if (not (record:rtd? rtd))
  50.       (slib:error "record-predicate: invalid argument." rtd))
  51.   (vector-ref rtd 6))
  52.  
  53. (define (make-record-type type-name field-names)
  54.   (if (not (string? type-name))
  55.       (slib:error "make-record-type: non-string type-name argument."
  56.           type-name))
  57.   (if (or (record:has-duplicates? field-names)
  58.       (comlist:notevery symbol? field-names))
  59.       (slib:error "make-record-type: illegal field-names argument."
  60.           field-names))
  61.   (let* ((corrected-length (+ 1 (length field-names)))
  62.      (rtd (vector record:*rtd-tag*
  63.               type-name
  64.               '()
  65.               field-names
  66.               corrected-length
  67.               #f
  68.               #f)))
  69.     (vector-set! rtd 5
  70.          (lambda (x)
  71.            (and (vector? x)
  72.             (= (vector-length x) corrected-length)
  73.             (eq? (record:record-rtd x) rtd))))
  74.     (vector-set! rtd 6
  75.          (lambda (x)
  76.            (and (vector? x)
  77.             (>= (vector-length x) corrected-length)
  78.             (or (eq? (record:record-rtd x) rtd)
  79.                 (memq rtd (record:record-supers x)))
  80.             #t)))
  81.     rtd))
  82.  
  83. (define (make-record-sub-type type-name field-names rtd)
  84.   (if (not (string? type-name))
  85.       (slib:error "make-record-sub-type: non-string type-name argument."
  86.           type-name))
  87.   (if (not (record:rtd? rtd))
  88.       (slib:error "make-record-sub-type: non-rtd rtd argument."
  89.           rtd))
  90.   (let ((xfield-names (append (record:rtd-fields rtd) field-names)))
  91.     (if (or (record:has-duplicates? xfield-names)
  92.         (comlist:notevery symbol? field-names))
  93.     (slib:error "make-record-sub-type: illegal field-names argument."
  94.             field-names))
  95.     (let* ((corrected-length (+ 1 (length xfield-names)))
  96.        (rtd (vector record:*rtd-tag*
  97.             type-name
  98.             (cons rtd (record:rtd-supers rtd))
  99.             xfield-names
  100.             corrected-length
  101.             #f
  102.             #f)))
  103.       (vector-set! rtd 5
  104.            (lambda (x)
  105.              (and (vector? x)
  106.               (= (vector-length x) corrected-length)
  107.               (eq? (record:record-rtd x) rtd))))
  108.       (vector-set! rtd 6
  109.            (lambda (x)
  110.              (and (vector? x)
  111.               (>= (vector-length x) corrected-length)
  112.               (or (eq? (record:record-rtd x) rtd)
  113.                   (memq rtd (record:record-supers x))))))
  114.       rtd)))
  115.  
  116. ; Determines whether or not a certain object looks like an rtd.
  117. ; Doesn't do as much error-checking as it could, but it would be quite
  118. ; unlikely for somebody to accidentally fool this function.
  119. (define (record:rtd? object)
  120.   (and (vector? object)
  121.        ;; Could check for the exact value here, but then I'd have to
  122.        ;; keep changing this as I change the format of a rtd.  This
  123.        ;; is good enough to get the vector-ref to work.
  124.        (not (= (vector-length object) 0))
  125.        (eq? (record:rtd-tag object) record:*rtd-tag*)))
  126.  
  127. (define (record-constructor rtd . field-names)
  128.   (if (not (record:rtd? rtd))
  129.       (slib:error "record-constructor: illegal rtd argument." rtd))
  130.   (if (or (null? field-names)
  131.       (equal? field-names (record:rtd-fields rtd)))
  132.       (let ((record-length (- (record:rtd-length rtd) 1)))
  133.     (lambda elts
  134.       (if (= (length elts) record-length) #t
  135.           (slib:error "record-constructor: "
  136.               (record:rtd-name rtd)
  137.               ": wrong number of arguments."))
  138.       (apply vector rtd elts)))
  139.       (let ((record-vfields (record:rtd-vfields rtd))
  140.         (corrected-record-length (record:rtd-length rtd))
  141.         (field-names (car field-names)))
  142.     (if (or (record:has-duplicates? field-names)
  143.         (comlist:notevery (lambda (x) (memq x record-vfields))
  144.               field-names))
  145.         (slib:error
  146.          "record-constructor: invalid field-names argument."
  147.          (cdr record-vfields)))
  148.     (let ((field-length (length field-names))
  149.           (offsets
  150.            (map (lambda (field) (comlist:position field record-vfields))
  151.             field-names)))
  152.       (lambda elts
  153.         (if (= (length elts) field-length) #t
  154.         (slib:error "record-constructor: "
  155.                 (record:rtd-name rtd)
  156.                 ": wrong number of arguments."))
  157.         (let ((result (make-vector corrected-record-length)))
  158.           (vector-set! result 0 rtd)
  159.           (for-each (lambda (offset elt)
  160.               (vector-set! result offset elt))
  161.             offsets
  162.             elts)
  163.           result))))))
  164.  
  165. (define (record-accessor rtd field-name)
  166.   (if (not (record:rtd? rtd))
  167.       (slib:error "record-accessor: invalid rtd argument." rtd))
  168.   (let ((index (comlist:position field-name (record:rtd-vfields rtd)))
  169.     (corrected-length (record:rtd-length rtd)))
  170.     (if (not index)
  171.     (slib:error "record-accessor: invalid field-name argument."
  172.             field-name))
  173.     (lambda (x)
  174.       (if (and (vector? x)
  175.            (>= (vector-length x) corrected-length)
  176.            (or (eq? rtd (record:record-rtd x))
  177.            (memq rtd (record:record-supers x))))
  178.       #t
  179.       (slib:error "record-accessor: wrong record type." x "not" rtd))
  180.       (vector-ref x index))))
  181.  
  182. (define (record-modifier rtd field-name)
  183.   (if (not (record:rtd? rtd))
  184.       (slib:error "record-modifier: invalid rtd argument." rtd))
  185.   (let ((index (comlist:position field-name (record:rtd-vfields rtd)))
  186.     (corrected-length (record:rtd-length rtd)))
  187.     (if (not index)
  188.     (slib:error "record-modifier: invalid field-name argument."
  189.             field-name))
  190.     (lambda (x y)
  191.       (if (and (vector? x)
  192.            (>= (vector-length x) corrected-length)
  193.            (or (eq? rtd (record:record-rtd x))
  194.            (memq rtd (record:record-supers x))))
  195.       #t
  196.       (slib:error "record-modifier: wrong record type." x "not" rtd))
  197.       (vector-set! x index y))))
  198.  
  199. (define (record? obj)
  200.   (and (vector? obj)
  201.        (>= (vector-length obj) 1)
  202.        (record:rtd? (record:record-rtd obj))
  203.        (= (vector-length obj)
  204.       (record:rtd-length (record:record-rtd obj)))))
  205.  
  206. (define (record-type-descriptor record)
  207.   (if (not (record? record))
  208.       (slib:error "record-type-descriptor: invalid argument."
  209.           record))
  210.   (record:record-rtd record))
  211.  
  212. (define (record-type-name rtd)
  213.   (if (not (record:rtd? rtd))
  214.       (perror "record-type-name: invalid argument."))
  215.   (record:rtd-name rtd))
  216.  
  217. ; For this function, make a copy of the value returned in order to
  218. ; make it a bit harder for the user to screw things up.
  219. (define (record-type-field-names rtd)
  220.   (if (not (record:rtd? rtd))
  221.       (slib:error "record-type-field-names: invalid argument." rtd))
  222.   (append (record:rtd-fields rtd) '()))
  223.